home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 7: Sunsite / Linux Cubed Series 7 - Sunsite Vol 1.iso / system / shells / scsh-0.4 / scsh-0 / scsh-0.4.2 / vm / stack.scm < prev    next >
Text File  |  1995-10-13  |  16KB  |  471 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: Scheme; -*-
  2.  
  3. ; This is file stack.scm.
  4.  
  5. ; *STACK-BEGIN* and *STACK-END* delimit the stack portion of memory.
  6. ; *STACK* points to the next unused cell on top of the stack.
  7. ; *STACK-LIMIT* is then end of the currently usable stack space.
  8. ; *BOTTOM-OF-STACK* is a continuation that lies a the base of the stack.
  9.  
  10. (define *stack-begin*     (unassigned))
  11. (define *stack-end*       (unassigned))
  12. (define *stack*           (unassigned))
  13. (define *stack-limit*     (unassigned))
  14. (define *bottom-of-stack* (unassigned))
  15.  
  16. (define *cont*            (unassigned))
  17.  
  18. ; For tracking the reason for copying closures and environments (used for
  19. ; debugging only).
  20.  
  21. (define-enumeration copy
  22.   (closure
  23.    overflow
  24.    preserve))
  25.  
  26. ; At the bottom of the stack is a special continuation that is never removed.
  27. ; When it is invoked it copies the next continuation out of the heap (if there
  28. ; is any such) and invokes that instead.
  29.  
  30. (define (initialize-stack start size)
  31.   (set! *stack-begin* start)
  32.   (set! *stack-end* (+ start (cells->a-units size)))
  33.   (set! *stack-limit* *stack-begin*)
  34.   (set! *stack* (the-pointer-before *stack-end*))
  35.   (set! *cont* false)
  36.   (set! *env* quiescent)
  37.   (push-continuation-on-stack (make-template-containing-ops
  38.                    (enum op get-cont-from-heap)
  39.                    (enum op return))
  40.                   (enter-fixnum 0)
  41.                   0
  42.                   universal-key)
  43.   (set! *bottom-of-stack* *cont*))
  44.  
  45. ; The amount of heap space required to initialize the stack.
  46. (define initial-stack-heap-space (op-template-size 2))
  47.  
  48. (define (reset-stack-pointer)
  49.   (set! *stack* (the-pointer-before
  50.          (the-pointer-before (address-after-header *bottom-of-stack*))))
  51.   (set-continuation-cont! *bottom-of-stack* (enter-boolean #f)))
  52.  
  53. (define (within-stack? p)
  54.   (and (addr>= p *stack-begin*)
  55.        (addr<= p *stack-end*)))
  56.  
  57. (define (stack-size)
  58.   (- *stack-end* *stack-begin*))
  59.  
  60. (define (available-on-stack? cells)
  61.   (addr> (addr- *stack* (cells->a-units cells)) *stack-limit*))
  62.  
  63. ; The + 1 is to get room for one header that is made.
  64. (define (current-stack-size)
  65.   (+ 1 (a-units->cells (addr- *stack-end* *stack*))))
  66.  
  67. ; Value of *NARGS* indicating that the arguments overflowed the stack limit
  68. (define arg-stack-overflow-nargs (+ maximum-stack-args 1))
  69.  
  70.  ; Room for MAXIMUM-STACK-ARGS plus one for the procedure argument to op/apply
  71. (define maximum-stack-arg-count (+ maximum-stack-args 1))
  72.  
  73. ; Add CELLS cells onto the stack.
  74. ; The stack grows towards negative memory.
  75.  
  76. (define (stack-add cells)
  77.   (set! *stack* (addr- *stack* (cells->a-units cells))))
  78.  
  79. (define (the-pointer-before x)
  80.   (addr- x (cells->a-units 1)))
  81.  
  82. (define (push x)     ; check for overflow is done when continuations are pushed
  83.   (store! *stack* x)
  84.   (stack-add 1))
  85.  
  86. (define (pop)
  87.   (stack-add -1)
  88.   (fetch *stack*))
  89.  
  90. (define (stack-ref index)
  91.   (fetch (addr+ *stack* (cells->a-units (+ 1 index)))))
  92.  
  93. (define (stack-set! index value)
  94.   (store! (addr+ *stack* (cells->a-units (+ 1 index))) value))
  95.  
  96. (define (pointer-to-stack-arguments)
  97.   (addr+ *stack* (cells->a-units 1)))
  98.  
  99. (define (remove-stack-arguments count)
  100.   (stack-add (- 0 count)))
  101.  
  102.  
  103. ; Making sure that no one uses stack space without checking for overflow.
  104.  
  105. ; Returns a key.  Only the most recent key is valid for allocating storage.
  106. ; UNIVERSAL-KEY is always valid.
  107.  
  108. (define (ensure-stack-space space ensure-space)
  109.   (if (not (available-on-stack? space))
  110.       (copy-stack-into-heap (ensure-space (current-stack-size))))
  111.   (preallocate-stack-space space))
  112.  
  113. (define (preallocate-stack-space space)
  114.   (cond (check-stack-preallocation?
  115.      (set! *stack-key* (+ *stack-key* -1)) ;go down to distinguish from heap keys
  116.      (set! *okayed-stack-space* space)
  117.      *stack-key*)
  118.     (else 0)))
  119.  
  120. (define check-stack-preallocation? #f)
  121. (define *stack-key* 0)
  122. (define *okayed-stack-space* 0)
  123.  
  124. ; Checks that KEY is the most recent key, and that the overflow check was
  125. ; made for at least CELLS space.
  126.  
  127. (define (check-stack-cons cells key)
  128.   (cond ((and check-stack-preallocation?
  129.           (not (= key universal-key)))
  130.      (if (not (and (= key *stack-key*)
  131.                (>= *okayed-stack-space* cells)))
  132.          (error "invalid stack key" key cells))
  133.      (set! *okayed-stack-space* (- *okayed-stack-space* cells)))))
  134.  
  135. ; Space for an exception continuation is reserved on the stack to
  136. ; ensure that pushing an exception continuation will not trigger a
  137. ; garbage collection.  Exceptions occur at points where there are
  138. ; live values that will not be found by the GC.
  139.  
  140. (define (reserve-stack-space size)
  141.   (set! *stack-limit* (+ *stack-begin* (cells->a-units size))))
  142.  
  143. (define (enable-stack-reserve)
  144.   (set! *stack-limit* *stack-begin*))
  145.  
  146. (define *exception-space-used?* #t)
  147.  
  148. (define (exception-frame-space exception-frame-size)
  149.   (if (and *exception-space-used?*
  150.        (not (available-on-stack? exception-frame-size)))
  151.       (current-stack-size)
  152.       0))
  153.  
  154. (define (reserve-exception-space exception-frame-size key)
  155.   (cond (*exception-space-used?*
  156.      (if (not (available-on-stack? exception-frame-size))
  157.          (error "no space on stack to reserve exception space"))
  158.      (reserve-stack-space exception-frame-size)
  159.      (set! *exception-space-used?* #f))))
  160.  
  161. (define (allow-exception-consing exception-frame-size)
  162.   (cond ((not (available-on-stack? exception-frame-size))
  163.      (enable-stack-reserve)
  164.      (set! *exception-space-used?* #t)
  165.      (if (not (available-on-stack? exception-frame-size))
  166.          (error "insufficient space on stack for exception frame"))))
  167.   (preallocate-stack-space exception-frame-size))
  168.  
  169.  
  170.  
  171. (define (peek-at-current-continuation)
  172.   (if (addr= *cont* *bottom-of-stack*)
  173.       (continuation-cont *bottom-of-stack*)
  174.       *cont*))
  175.  
  176. ; Skip to the continuation preceding the current one (used for multiple
  177. ; value returns).
  178.  
  179. (define (skip-current-continuation!)
  180.   (let ((next (continuation-cont *cont*)))
  181.     (if (addr= *cont* *bottom-of-stack*)
  182.     (set-continuation-cont! *cont* (continuation-cont next))
  183.     (set! *cont* next))))
  184.  
  185. ; Called when replacing the current continuation with a new one.
  186.  
  187. (define (set-current-continuation! cont)
  188.   (set! *cont* (cond ((false? cont)
  189.               (reset-stack-pointer)
  190.               *bottom-of-stack*)
  191.              (else
  192.               (copy-continuation-from-heap cont)))))
  193.  
  194. ; Called when returning off of the end of the stack.
  195.  
  196. (define (get-continuation-from-heap)
  197.   (continuation-cont *bottom-of-stack*))
  198.  
  199. ; Copy CONT from heap onto stack just above *BOTTOM-OF-STACK*, linking it
  200. ; to *BOTTOM-OF-STACK* and *BOTTOM-OF-STACK* to CONT's continuation.
  201.  
  202. (define (copy-continuation-from-heap cont)
  203.   (assert (continuation? cont))
  204.   (let* ((top (addr- (address-at-header *bottom-of-stack*)
  205.                      (addr1+ (cells->a-units (continuation-length cont)))))
  206.          (new-cont (address->stob-descriptor (addr1+ top))))
  207.     (add-copy-cont-from-heap-stats cont)
  208.     (set! *stack* (the-pointer-before top))
  209.     (copy-cells! (address-at-header cont) top (+ 1 (continuation-length cont)))
  210.     (set-continuation-cont! *bottom-of-stack* (continuation-cont new-cont))
  211.     (set-continuation-cont! new-cont *bottom-of-stack*)
  212.     new-cont))
  213.  
  214.  
  215. ; Pushing and popping continuations.
  216.  
  217. (define stack-continuation-size
  218.   (+ (+ continuation-cells 1)     ; header
  219.      maximum-stack-arg-count))    ; pre-checking for pushed arguments
  220.  
  221. (define (push-continuation-on-stack template pc arg-count key)
  222.   (check-stack-cons stack-continuation-size key)
  223.   (add-continuation-stats arg-count)
  224.   (stack-add (+ 1 continuation-cells))
  225.   (store! (addr1+ *stack*) (make-continuation-header arg-count))
  226.   (let ((cont (address->stob-descriptor (addr1+ (addr1+ *stack*)))))
  227.     (set-continuation-pc!       cont pc)
  228.     (set-continuation-template! cont template)
  229.     (set-continuation-env!      cont *env*)
  230.     (set-continuation-cont!     cont *cont*)
  231.     (set! *cont* cont)))
  232.  
  233. (define make-continuation-header
  234.   (let ((type (enum stob continuation)))
  235.     (lambda (arg-count)
  236.       (make-header-immutable
  237.        (make-header type (cells->bytes (+ arg-count continuation-cells)))))))
  238.  
  239. (define (pop-continuation-from-stack set-template!)
  240.   (let ((cont *cont*))
  241.     (set-template! (continuation-template cont)
  242.            (continuation-pc       cont))
  243.     (set! *env*    (continuation-env      cont))
  244.     (set! *cont*   (continuation-cont     cont))
  245.     (set! *stack* (addr+ (address-at-header cont)
  246.              (cells->a-units continuation-cells)))))
  247.  
  248. ; Making environments on the stack - the values are already there so this
  249. ; only needs to push space for a pointer and push a header.
  250.  
  251.  
  252. ; Copying the stack into the heap because there is no more room on the
  253. ; stack.  This copies any arguments that are on the top of the stack into
  254. ; a vector, migrates and recovers the current, and then moves the arguments
  255. ; from the vector back to the stack.
  256. ;
  257. ; Why can't this move the arguments directly?  The restored continuation
  258. ; cannot be larger than the original.
  259.  
  260. (define (copy-stack-into-heap key)
  261.   (let* ((arg-count (arguments-on-stack))
  262.          (vec (vm-make-vector arg-count key)))
  263.     (do ((i (+ -1 arg-count) (- i 1)))
  264.         ((<= i -1))
  265.       (vm-vector-set! vec i (pop)))
  266.     (preserve-continuation key (enum copy overflow))
  267.     (do ((i 0 (+ i 1)))
  268.         ((>= i arg-count))
  269.       (push (vm-vector-ref vec i)))
  270.     (unassigned)))
  271.  
  272. (define (arguments-on-stack)
  273.   (do ((p (addr1+ *stack*) (addr1+ p))
  274.        (i 0 (+ i 1)))
  275.       ((header? (fetch p)) i)))
  276.  
  277. ; Migrating the current continuation into the heap, saving the environment
  278. ; first.
  279.  
  280. (define current-continuation-size current-stack-size)
  281.  
  282. (define (current-continuation key)
  283.   (preserve-continuation key (enum copy preserve)))
  284.  
  285. (define (preserve-continuation key reason)
  286.   (preserve-current-env-with-reason key reason)
  287.   (let ((end (continuation-cont *bottom-of-stack*)))
  288.     (let loop ((cont *cont*) (previous *bottom-of-stack*))
  289.       (cond ((vm-eq? cont *bottom-of-stack*)
  290.          (set-continuation-cont! previous end))
  291.             (else
  292.              (if (within-stack? (continuation-env cont))
  293.                  (save-env-in-heap (continuation-env cont) cont key reason)
  294.          0) ; for type inferencer (which could use some improvement)
  295.              (let ((new (copy-stob cont key)))
  296.            (add-preserve-cont-stats new reason)
  297.                (set-continuation-cont! previous new)
  298.                (loop (continuation-cont new) new)))))
  299.     (let ((cont (continuation-cont *bottom-of-stack*)))
  300.       (set! *cont* (if (false? cont)
  301.                *bottom-of-stack*
  302.                (copy-continuation-from-heap cont)))
  303.       cont)))
  304.  
  305.  
  306. ; Copy NARGS arguments from the top of the stack to just above CONT.
  307. ; Used by OP/MOVE-ARGS-AND-CALL to implement tail-recursive calls.
  308. ; 
  309. ; The IF saves work in a rare case at the cost of a test in the common
  310. ; case; is it worth it?
  311.  
  312. (define (move-args-above-cont! nargs)
  313.   (let ((start-loc (the-pointer-before (address-at-header *cont*)))
  314.     (start-arg (addr+ *stack* (cells->a-units nargs))))
  315.     (if (not (addr<= start-loc start-arg))
  316.     (do ((loc start-loc (the-pointer-before loc))
  317.          (arg start-arg (the-pointer-before arg)))
  318.         ((addr<= arg *stack*)
  319.          (set! *stack* loc))
  320.       (store! loc (fetch arg))))))
  321.  
  322. ; Tracing the stack for garbage collection - first trace any arguments pushed
  323. ; above the current continuation, then loop down the continuations, tracing
  324. ; each one along with its environment (if the environment has not yet been
  325. ; done).
  326.  
  327. (define (trace-stack trace-locations)
  328.   (trace-locations (addr1+ *stack*) (address-at-header *cont*))
  329.   (let loop ((cont *cont*) (last-env 0))
  330.     (let ((env (continuation-env cont)))
  331.       (trace-locations (address-after-header cont) (address-after-stob cont))
  332.       (if (not (vm-eq? env last-env))
  333.       (trace-env env trace-locations))
  334.       (if (not (vm-eq? cont *bottom-of-stack*))
  335.       (loop (continuation-cont cont) env)))))
  336.  
  337. ; I do not think that the recursive call is necessary as the superior
  338. ; env will be traced by TRACE-STACK as it goes down the list of
  339. ; continuations.  For every superior env that is on the stack, there should
  340. ; be a continuation on the stack that points to it.
  341.  
  342. (define (trace-env env trace-locations)
  343.   (let loop ((env env))
  344.     (cond ((within-stack? env)
  345.        (trace-locations (address-after-header env) (address-after-stob env))
  346.        (loop (vm-vector-ref env 0))))))
  347.  
  348.  
  349. ; Collecting and printing statistics on stack usage
  350.  
  351. (define collect-statistics? #f)
  352.  
  353. (define *conts* 0)
  354. (define *conts-slots* 0)
  355. (define *conts-overflow* 0)
  356. (define *conts-overflow-slots* 0)
  357. (define *conts-preserved* 0)
  358. (define *conts-preserved-slots* 0)
  359. (define *conts-from-heap* 0)
  360. (define *conts-from-heap-slots* 0)
  361.  
  362. (define *envs* 0)
  363. (define *envs-slots* 0)
  364. (define *envs-closed* 0)
  365. (define *envs-closed-slots* 0)
  366. (define *envs-overflow* 0)
  367. (define *envs-overflow-slots* 0)
  368. (define *envs-preserved* 0)
  369. (define *envs-preserved-slots* 0)
  370.  
  371. (define (reset-stack-stats)
  372.   (cond (collect-statistics?
  373.      (set! *conts* 0)
  374.      (set! *conts-slots* 0)
  375.      (set! *conts-overflow* 0)
  376.      (set! *conts-overflow-slots* 0)
  377.      (set! *conts-preserved* 0)
  378.      (set! *conts-preserved-slots* 0)
  379.      (set! *conts-from-heap* 0)
  380.      (set! *conts-from-heap-slots* 0)
  381.  
  382.      (set! *envs* 0)
  383.      (set! *envs-slots* 0)
  384.      (set! *envs-closed* 0)
  385.      (set! *envs-closed-slots* 0)
  386.      (set! *envs-overflow* 0)
  387.      (set! *envs-overflow-slots* 0)
  388.      (set! *envs-preserved* 0)
  389.      (set! *envs-preserved-slots* 0)
  390.      )
  391.     (else 0)))
  392.  
  393. (define (print-stack-stats port)
  394.   (if collect-statistics?
  395.       (really-print-stack-stats port)))
  396.  
  397. (define (really-print-stack-stats port)
  398.   (let ((one-record (lambda (name count slots port)
  399.               (newline port)
  400.               (write-string "(" port)
  401.               (write-string name port)
  402.               (write-string " " port)
  403.               (write-number count port)
  404.               (write-number slots port)
  405.               (write-string ")" port))))
  406.     (newline port)
  407.     (write-string "(continuations" port)
  408.     (one-record "made" *conts* *conts-slots* port)
  409.     (one-record "overflow" *conts-overflow* *conts-overflow-slots* port)
  410.     (one-record "preserved" *conts-preserved* *conts-preserved-slots* port)
  411.     (one-record "from-heap" *conts-from-heap* *conts-from-heap-slots* port)
  412.     (write-string ")" port)
  413.  
  414.     (newline port)
  415.     (write-string "(environments" port)
  416.     (one-record "made" *envs* *envs-slots* port)
  417.     (one-record "closed" *envs-closed* *envs-closed-slots* port)
  418.     (one-record "overflow" *envs-overflow* *envs-overflow-slots* port)
  419.     (one-record "preserved" *envs-preserved* *envs-preserved-slots* port)
  420.     (write-string ")" port)
  421.     (newline port)
  422.     ))
  423.  
  424. (define (add-continuation-stats arg-count)
  425.   (cond (collect-statistics?
  426.      (set! *conts* (+ *conts* 1))
  427.      (set! *conts-slots*
  428.            (+ *conts-slots* (+ arg-count continuation-cells))))))
  429.  
  430.  
  431. (define (add-env-stats count)
  432.   (cond (collect-statistics?
  433.      (set! *envs* (+ *envs* 1))
  434.      (set! *envs-slots* (+ *envs-slots* (+ count 1))))))
  435.  
  436. (define (add-copy-env-stats env reason)
  437.     (cond ((not collect-statistics?)
  438.        (unassigned))
  439.       ((= reason (enum copy closure))
  440.        (set! *envs-closed* (+ *envs-closed* 1))
  441.        (set! *envs-closed-slots*
  442.          (+ *envs-closed-slots* (vm-vector-length env))))
  443.       ((= reason (enum copy overflow))
  444.        (set! *envs-overflow* (+ *envs-overflow* 1))
  445.        (set! *envs-overflow-slots*
  446.          (+ *envs-overflow-slots* (vm-vector-length env))))
  447.       ((= reason (enum copy preserve))
  448.        (set! *envs-preserved* (+ *envs-preserved* 1))
  449.        (set! *envs-preserved-slots*
  450.          (+ *envs-preserved-slots* (vm-vector-length env))))))
  451.  
  452. (define (add-preserve-cont-stats new reason)
  453.   (cond ((not collect-statistics?)
  454.      (unassigned))
  455.     ((= reason (enum copy overflow))
  456.      (set! *conts-overflow* (+ *conts-overflow* 1))
  457.      (set! *conts-overflow-slots*
  458.            (+ *conts-overflow-slots*
  459.           (continuation-length new))))
  460.     ((= reason (enum copy preserve))
  461.      (set! *conts-preserved* (+ *conts-preserved* 1))
  462.      (set! *conts-preserved-slots*
  463.            (+ *conts-preserved-slots*
  464.           (continuation-length new))))))
  465.  
  466. (define (add-copy-cont-from-heap-stats cont)
  467.   (cond (collect-statistics?
  468.      (set! *conts-from-heap* (+ *conts-from-heap* 1))
  469.      (set! *conts-from-heap-slots* (+ *conts-from-heap-slots*
  470.                       (continuation-length cont))))))
  471.